home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic Graphics Programming (2nd Edition)
/
Visual Basic Graphics Programming 2nd Edition.iso
/
OldSrc
/
CH11
/
SRC
/
OBJPGON3.CLS
< prev
next >
Wrap
Text File
|
1996-05-04
|
19KB
|
699 lines
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ObjPolygon"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Point3D is defined in module M3OPS.BAS as:
' Type Point3D
' coord(1 To 4) As Single
' trans(1 To 4) As Single
' End Type
Private NumPts As Integer ' Number of points.
Private Points() As Point3D ' Data points.
Private IsCulled As Boolean
' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox. Use the API function Polygon so
' the polygon will be properly filled to cover
' polygons behind it.
' ************************************************
Public Sub DrawOrdered(canvas As Object, Optional r As Variant)
Dim pts() As POINTAPI
Dim pt As Integer
Dim status As Integer
' Don't draw if culled.
If IsCulled Then Exit Sub
' Fill in the point array.
ReDim pts(1 To NumPts)
For pt = 1 To NumPts
pts(pt).x = Points(pt).trans(1)
pts(pt).Y = Points(pt).trans(2)
Next pt
' Draw the polygon.
On Error Resume Next
status = Polygon(canvas.hdc, pts(1), NumPts)
End Sub
' ************************************************
' Return the minimum and maximum coordinates.
' ************************************************
Public Sub GetExtent(Xmin As Single, xmax As Single, ymin As Single, ymax As Single, zmin As Single, zmax As Single)
Dim i As Integer
Dim x As Single
Dim Y As Single
Dim z As Single
Xmin = Points(1).trans(1)
xmax = Xmin
ymin = Points(1).trans(2)
ymax = ymin
zmin = Points(1).trans(3)
zmax = zmin
For i = 2 To NumPts
x = Points(i).trans(1)
Y = Points(i).trans(2)
z = Points(i).trans(3)
If Xmin > x Then Xmin = x
If xmax < x Then xmax = x
If ymin > Y Then ymin = Y
If ymax < Y Then ymax = Y
If zmin > z Then zmin = z
If zmax < z Then zmax = z
Next i
End Sub
' ************************************************
' Return the coordinates of a point on the polygon.
' ************************************************
Public Sub GetTransformedPoint(Index As Integer, x As Single, Y As Single, z As Single)
x = Points(Index).trans(1)
Y = Points(Index).trans(2)
z = Points(Index).trans(3)
End Sub
' ************************************************
' See where the projections of two segments cross.
' Return true if the segments cross, false
' otherwise.
' ************************************************
Function FindCrossing( _
ax1 As Single, ay1 As Single, az1 As Single, _
ax2 As Single, ay2 As Single, az2 As Single, _
bx1 As Single, by1 As Single, bz1 As Single, _
bx2 As Single, by2 As Single, bz2 As Single, _
x As Single, Y As Single, z1 As Single, z2 As Single) _
As Boolean
Dim dxa As Single
Dim dya As Single
Dim dza As Single
Dim dxb As Single
Dim dyb As Single
Dim dzb As Single
Dim t1 As Single
Dim t2 As Single
Dim denom As Single
dxa = ax2 - ax1
dya = ay2 - ay1
dxb = bx2 - bx1
dyb = by2 - by1
FindCrossing = False
denom = dxb * dya - dyb * dxa
' If the segments are parallel, stop.
If denom < 0.01 And denom > -0.01 Then Exit Function
t2 = (ax1 * dya - ay1 * dxa - bx1 * dya + by1 * dxa) / denom
If t2 < 0 Or t2 > 1 Then Exit Function
t1 = (ax1 * dyb - ay1 * dxb - bx1 * dyb + by1 * dxb) / denom
If t1 < 0 Or t1 > 1 Then Exit Function
' Compute the points of overlap.
x = ax1 + t1 * dxa
Y = ay1 + t1 * dya
dza = az2 - az1
dzb = bz2 - bz1
z1 = az1 + t1 * dza
z2 = bz1 + t2 * dzb
FindCrossing = True
End Function
' ************************************************
' Return the number of points.
' ************************************************
Property Get NumPoints() As Integer
NumPoints = NumPts
End Property
' ************************************************
' Return true if this polygon partially obscures
' (has greater Z value than) polygon obj.
'
' We assume one polygon may obscure the other, but
' they cannot obscure each other.
'
' This check is executed by seeing where the
' projections of the edges of the polygons cross.
' Where they cross, see if one Z value is greater
' than the other.
'
' If no edges cross, see if one polygon contains
' the other. If so, there is an overlap.
' ************************************************
Public Function Obscures(obj As ObjPolygon) As Boolean
Dim num As Integer
Dim i As Integer
Dim j As Integer
Dim xi1 As Single
Dim yi1 As Single
Dim zi1 As Single
Dim xi2 As Single
Dim yi2 As Single
Dim zi2 As Single
Dim xj1 As Single
Dim yj1 As Single
Dim zj1 As Single
Dim xj2 As Single
Dim yj2 As Single
Dim zj2 As Single
Dim x As Single
Dim Y As Single
Dim z1 As Single
Dim z2 As Single
num = obj.NumPoints
' Check each edge in this polygon.
GetTransformedPoint NumPts, xi1, yi1, zi1
For i = 1 To NumPts
GetTransformedPoint i, xi2, yi2, zi2
' Compare with each edge in the other.
obj.GetTransformedPoint num, xj1, yj1, zj1
For j = 1 To num
obj.GetTransformedPoint j, xj2, yj2, zj2
' See if the segments cross.
If FindCrossing( _
xi1, yi1, zi1, _
xi2, yi2, zi2, _
xj1, yj1, zj1, _
xj2, yj2, zj2, _
x, Y, z1, z2) _
Then
If z1 - z2 > 0.01 Then
' z1 > z2. We obscure it.
Obscures = True
Exit Function
End If
If z2 - z1 > 0.01 Then
' z2 > z1. It obscures us.
Obscures = False
Exit Function
End If
End If
xj1 = xj2
yj1 = yj2
zj1 = zj2
Next j
xi1 = xi2
yi1 = yi2
zi1 = zi2
Next i
' No edges cross. See if one polygon contains
' the other.
' If any points of one polygon are inside the
' other, then they must all be. Since the
' IsAbove tests were inconclusive, some points
' in one polygon are on the "bad" side of the
' other. In that case there is an overlap.
' See if this polygon is inside the other.
GetTransformedPoint 1, xi1, yi1, zi1
If obj.PointInside(xi1, yi1) Then
Obscures = True
Exit Function
End If
' See if the other polygon is inside this one.
obj.GetTransformedPoint 1, xi1, yi1, zi1
If PointInside(xi1, yi1) Then
Obscures = True
Exit Function
End If
Obscures = False
End Function
' ************************************************
' Return true if the point projection lies within
' this polygon's projection.
' ************************************************
Function PointInside(x As Single, Y As Single) As Boolean
Dim i As Integer
Dim theta1 As Double
Dim theta2 As Double
Dim dtheta As Double
Dim dx As Double
Dim dy As Double
Dim angles As Double
dx = Points(NumPts).trans(1) - x
dy = Points(NumPts).trans(2) - Y
theta1 = Arctan2(CSng(dx), CSng(dy))
If theta1 < 0 Then theta1 = theta1 + 2 * PI
For i = 1 To NumPts
dx = Points(i).trans(1) - x
dy = Points(i).trans(2) - Y
theta2 = Arctan2(CSng(dx), CSng(dy))
If theta2 < 0 Then theta2 = theta2 + 2 * PI
dtheta = theta2 - theta1
If dtheta > PI Then dtheta = dtheta - 2 * PI
If dtheta < -PI Then dtheta = dtheta + 2 * PI
angles = angles + dtheta
theta1 = theta2
Next i
PointInside = (Abs(angles) > 0.001)
End Function
' ************************************************
' Return true if this polygon is completly below
' the plane containing obj.
' ************************************************
Public Function IsBelow(obj As ObjPolygon) As Boolean
Dim nx As Single
Dim ny As Single
Dim nz As Single
Dim px As Single
Dim py As Single
Dim pz As Single
Dim dx As Single
Dim dy As Single
Dim dz As Single
Dim cx As Single
Dim cy As Single
Dim cz As Single
Dim i As Integer
' Compute a downward pointing normal to the plane.
obj.TransformedNormalVector nx, ny, nz
If nz > 0 Then
nx = -nx
ny = -ny
nz = -nz
End If
' Get a point on the plane.
obj.GetTransformedPoint 1, px, py, pz
' See if the points in this polygon all lie
For i = 1 To NumPts
' Get the vector from plane to point.
dx = Points(i).trans(1) - px
dy = Points(i).trans(2) - py
dz = Points(i).trans(3) - pz
' If the dot product < 0, the point is
' below the plane.
If dx * nx + dy * ny + dz * nz < -0.01 Then
IsBelow = False
Exit Function
End If
Next i
IsBelow = True
End Function
' ************************************************
' Return true if this polygon is completly above
' the plane containing obj.
' ************************************************
Public Function IsAbove(obj As ObjPolygon) As Boolean
Dim nx As Single
Dim ny As Single
Dim nz As Single
Dim px As Single
Dim py As Single
Dim pz As Single
Dim dx As Single
Dim dy As Single
Dim dz As Single
Dim cx As Single
Dim cy As Single
Dim cz As Single
Dim i As Integer
' Compute an upward pointing normal to the plane.
obj.TransformedNormalVector nx, ny, nz
If nz < 0 Then
nx = -nx
ny = -ny
nz = -nz
End If
' Get a point on the plane.
obj.GetTransformedPoint 1, px, py, pz
' See if the points in this polygon all lie
For i = 1 To NumPts
' Get the vector from plane to point.
dx = Points(i).trans(1) - px
dy = Points(i).trans(2) - py
dz = Points(i).trans(3) - pz
' If the dot product < 0, the point is
' below the plane.
If dx * nx + dy * ny + dz * nz < -0.01 Then
IsAbove = False
Exit Function
End If
Next i
IsAbove = True
End Function
' ***********************************************
' Return the maximum transformed Z value for this
' object.
' ***********************************************
Property Get zmax() As Single
Dim best As Single
Dim z As Single
Dim i As Integer
best = Points(1).trans(3)
For i = 2 To NumPts
z = Points(i).trans(3)
If best < z Then best = z
Next i
zmax = best
End Property
' ***********************************************
' Create a polyline representing the normal to
' this polygon and place it in the given objects
' collection.
' ***********************************************
Sub CreateNormal(Objects As Collection)
Dim pline As New ObjPolyline
Dim x1 As Single
Dim y1 As Single
Dim z1 As Single
Dim x2 As Single
Dim y2 As Single
Dim z2 As Single
Objects.Add pline
UnitNormalSegment x1, y1, z1, x2, y2, z2
pline.AddSegment x1, y1, z1, x2, y2, z2
End Sub
' ***********************************************
' Compute a transformed normal vector.
' ***********************************************
Public Sub TransformedNormalVector(nx As Single, ny As Single, nz As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim Bx As Single
Dim By As Single
Dim Bz As Single
Ax = Points(2).trans(1) - Points(1).trans(1)
Ay = Points(2).trans(2) - Points(1).trans(2)
Az = Points(2).trans(3) - Points(1).trans(3)
Bx = Points(3).trans(1) - Points(2).trans(1)
By = Points(3).trans(2) - Points(2).trans(2)
Bz = Points(3).trans(3) - Points(2).trans(3)
m3Cross nx, ny, nz, Ax, Ay, Az, Bx, By, Bz
End Sub
' ***********************************************
' Compute a normal vector for this polygon.
' ***********************************************
Public Sub NormalVector(nx As Single, ny As Single, nz As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim Bx As Single
Dim By As Single
Dim Bz As Single
Ax = Points(2).coord(1) - Points(1).coord(1)
Ay = Points(2).coord(2) - Points(1).coord(2)
Az = Points(2).coord(3) - Points(1).coord(3)
Bx = Points(3).coord(1) - Points(2).coord(1)
By = Points(3).coord(2) - Points(2).coord(2)
Bz = Points(3).coord(3) - Points(2).coord(3)
m3Cross nx, ny, nz, Ax, Ay, Az, Bx, By, Bz
End Sub
' ***********************************************
' Compute the unit normal line segment for this
' polygon.
' ***********************************************
Sub UnitNormalSegment(x1 As Single, y1 As Single, z1 As Single, x2 As Single, y2 As Single, z2 As Single)
Dim i As Integer
Dim nx As Single
Dim ny As Single
Dim nz As Single
UnitNormalVector nx, ny, nz
x1 = 0
y1 = 0
z1 = 0
For i = 1 To NumPts
x1 = x1 + Points(i).coord(1)
y1 = y1 + Points(i).coord(2)
z1 = z1 + Points(i).coord(3)
Next i
x1 = x1 / NumPts
y1 = y1 / NumPts
z1 = z1 / NumPts
x2 = x1 + nx
y2 = y1 + ny
z2 = z1 + nz
End Sub
' ***********************************************
' Compute the unit normal vector for this
' polygon.
' ***********************************************
Sub UnitNormalVector(nx As Single, ny As Single, nz As Single)
Dim D As Single
NormalVector nx, ny, nz
D = Sqr(nx * nx + ny * ny + nz * nz)
nx = nx / D
ny = ny / D
nz = nz / D
End Sub
' ***********************************************
' Set or clear the IsCulled flag.
' ***********************************************
Property Let Culled(value As Boolean)
IsCulled = value
End Property
' ***********************************************
' Return true if the polygon has been culled.
' ***********************************************
Property Get Culled() As Boolean
Culled = IsCulled
End Property
' ***********************************************
' Return a string indicating the object type.
' ***********************************************
Property Get ObjectType() As String
ObjectType = "POLYGON"
End Property
' ************************************************
' Add one or more points to the polygon.
' ************************************************
Public Sub AddPoint(ParamArray coord() As Variant)
Dim num_pts As Integer
Dim i As Integer
Dim pt As Integer
num_pts = (UBound(coord) + 1) \ 3
ReDim Preserve Points(1 To NumPts + num_pts)
pt = 0
For i = 1 To num_pts
Points(NumPts + i).coord(1) = coord(pt)
Points(NumPts + i).coord(2) = coord(pt + 1)
Points(NumPts + i).coord(3) = coord(pt + 2)
Points(NumPts + i).coord(4) = 1#
pt = pt + 3
Next i
NumPts = NumPts + num_pts
End Sub
' ***********************************************
' Fix the data coordinates at their transformed
' values.
' ***********************************************
Public Sub FixPoints()
Dim i As Integer
Dim j As Integer
For i = 1 To NumPts
For j = 1 To 3
Points(i).coord(j) = Points(i).trans(j)
Next j
Next i
End Sub
' ************************************************
' Apply a transformation matrix which may not
' contain 0, 0, 0, 1 in the last column to the
' object.
' ************************************************
Public Sub ApplyFull(M() As Single)
Dim i As Integer
If IsCulled Then Exit Sub
For i = 1 To NumPts
m3ApplyFull Points(i).coord, M, Points(i).trans
Next i
End Sub
' ************************************************
' Apply a transformation matrix to the object.
' ************************************************
Public Sub Apply(M() As Single)
Dim i As Integer
If IsCulled Then Exit Sub
For i = 1 To NumPts
m3Apply Points(i).coord, M, Points(i).trans
Next i
End Sub
' ************************************************
' Apply a nonlinear transformation.
' ************************************************
Public Sub Distort(D As Object)
Dim i As Integer
For i = 1 To NumPts
D.Distort Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
Next i
End Sub
' ************************************************
' Write a polyline to a file using Write.
' Begin with "POLYGON" to identify this object.
' ************************************************
Public Sub FileWrite(filenum As Integer)
Dim i As Integer
Write #filenum, "POLYGON", NumPts
' Write the points.
For i = 1 To NumPts
Write #filenum, Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
Next i
End Sub
' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox.
' ************************************************
Public Sub Draw(canvas As Object, Optional r As Variant)
Dim pt As Integer
' Don't draw if culled.
If IsCulled Then Exit Sub
On Error Resume Next
canvas.CurrentX = Points(NumPts).trans(1)
canvas.CurrentY = Points(NumPts).trans(2)
For pt = 1 To NumPts
canvas.Line _
-(Points(pt).trans(1), Points(pt).trans(2))
Next pt
End Sub
' ***********************************************
' Cull if any points are behind the center of
' projection.
' ***********************************************
Public Sub ClipEye(r As Single)
Dim pt As Integer
If IsCulled Then Exit Sub
For pt = 1 To NumPts
If Points(pt).trans(3) >= r Then Exit For
Next pt
If pt <= NumPts Then IsCulled = True
End Sub
' ***********************************************
' Perform backface removal.
' ***********************************************
Public Sub Cull(x As Single, Y As Single, z As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim nx As Single
Dim ny As Single
Dim nz As Single
' Compute a normal to the face.
NormalVector nx, ny, nz
' Compute a vector from the center of
' projection to the face.
Ax = Points(1).coord(1) - x
Ay = Points(1).coord(2) - Y
Az = Points(1).coord(3) - z
' See if the vectors meet at an angle < 90.
IsCulled = (Ax * nx + Ay * ny + Az * nz > -0.0001)
End Sub
' ************************************************
' Read a polyline from a file using Input.
' Assume the "POLYGON" label has already been
' read.
' ************************************************
Public Sub FileInput(filenum As Integer)
Dim i As Integer
Input #filenum, NumPts
' Allocate and read the points.
ReDim Points(1 To NumPts)
For i = 1 To NumPts
Input #filenum, Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
Points(i).coord(4) = 1#
Next i
End Sub